home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Contributed / SCOOPS / scoops.sch < prev   
Encoding:
Text File  |  1989-01-10  |  28.5 KB  |  814 lines  |  [TEXT/EDIT]
  1. ; Copyright (C) 1987 John Ulrich
  2. ; Permission to copy this software, in whole or in part, to use this
  3. ; software for any lawful purpose, and to redistribute this software
  4. ; is granted subject to the restriction that all copies made of this
  5. ; software must include this copyright notice in full.
  6. ; Neither John Ulrich nor Semantic Microsystems, Inc. make any warranty 
  7. ; or representation of any kind concerning this software, either express
  8. ; or implied, including but not limited to implied warranties of
  9. ; merchantability or fitness for any particular purpose.
  10.  
  11. (begin (set! include-source-code? #f)
  12.        (set! include-lambda-list? #f)
  13.        (set! include-procedure-name? #f))
  14.  
  15. ; Variables assigned by this file
  16.  
  17. (define describe)
  18. (define name->class)
  19. (define all-classvars)
  20. (define all-methods)
  21. (define class-compiled?)
  22. (define class-of-object)
  23. (define classvars)
  24. (define compile-class)
  25. (define define-class)
  26. (define define-method)
  27. (define delete-method)
  28. (define getcv)
  29. (define setcv)
  30. (define instvars)
  31. (define make-instance)
  32. (define methods)
  33. (define mixins)
  34. (define rename-class)
  35.  
  36. (define send:
  37.   (lambda x
  38.     (let ((object (car x))(tail (cdr x)))
  39.       (cond ((null? tail)
  40.              (cerror "null message sent" object))
  41.             (else
  42.              (let*  ((proc (car (->pair object)))
  43.                      (proc (if (procedure? proc)
  44.                                (proc (car tail))
  45.                                (cerror "bad argument to object" object))))
  46.                (if (procedure? proc) (apply proc (cdr tail))
  47.                                      (cerror "message not recieved" x))))))))
  48.  
  49. (define dispatch
  50.   (lambda (object msg)
  51.     (let ((proc (car (->pair object))))
  52.       (if (procedure? proc)
  53.           (proc msg)
  54.           (cerror "bad argument to object"
  55.                   object)))))
  56.  
  57. (define send-if-handles:
  58.   (lambda x
  59.     (let ((object (car x))(tail (cdr x)))
  60.       (cond ((null? tail)
  61.              (cerror "null message sent" object))
  62.             (else
  63.              (let*  ((proc (car (->pair object)))
  64.                      (proc (if (procedure? proc)
  65.                                (proc (car tail))
  66.                                (cerror "bad argument to object" object))))
  67.                (if (procedure? proc) (apply proc (cdr tail))
  68.                                      )))))))
  69.  
  70.  
  71. ;;; the following two macros are for compatibility
  72.  
  73. (macro send (lambda (x)`(send: ,(cadr x) ',(caddr x) ,@(cdddr x))))
  74. (macro send-if-handles
  75.        (lambda (x)
  76.          `(send-if-handles: ,(cadr x) ',(caddr x) ,@(cdddr x))))
  77.  
  78. ; Variables assigned temporarily and then made undefined.
  79. ; This was done to make it possible to compile this file
  80. ; on a one megabyte machine.
  81.  
  82. (define *key*)
  83. (define inheritance)
  84. (define lookup-class)
  85. (define process-tail)
  86. (define process-option)
  87. (define instance-vars)
  88. (define class-vars)
  89. (define eqcar)
  90. (define attach-prefix)
  91. (define remdup)
  92. (define union)
  93. (define add-member)
  94. (define delete)
  95. (define set-value)
  96. (define get-value)
  97. (define locate)
  98. (define class-description)
  99. (define instance-description)
  100. (define class-list)
  101. (define class-list-set!)
  102.  
  103. (let ((*class-list* '()))
  104.   (set! class-list
  105.         (lambda () *class-list*))
  106.   (set! class-list-set!
  107.         (lambda (x) (set! *class-list* x)))
  108.   #t)
  109.  
  110. (define *key* (gensym "key"))
  111.  
  112. ;inheritance is a real time sink.  Perhaps someone can think of a better
  113. ;way. For starters the name-space includes everything.  We could break
  114. ;out name-space-vars name-space-methods which would reduce the work
  115. ;performed by member.  However, I feel that some more basic changes
  116. ;could be made that would improve the efficiency
  117.  
  118. (define inheritance
  119.   (let ((*key* *key*))
  120.     (define map-inheritance
  121.       (let ()
  122.         (define (map-inheritance1 mixins msg)
  123.           (cond
  124.            ((null? mixins) '())
  125.            (else (append (map-inheritance (car mixins) msg)
  126.                          (map-inheritance1 (cdr mixins) msg)))))
  127.         (lambda (class msg)
  128.           (cons (cons class (send: (class *key*) msg))
  129.                 (map-inheritance1 (send (class *key*) get-mixins) msg)))))
  130.     (define shadow
  131.       (let ()
  132.         (define filter
  133.           (lambda (x fn)
  134.             (cond
  135.              ((null? x) '())
  136.              ((fn (car x)) (filter (cdr x) fn))
  137.              (else (cons (car x)(filter (cdr x) fn))))))
  138.         (lambda (lst msg)
  139.           (cond
  140.            ((null? lst) '())
  141.            (else
  142.             (letrec
  143.               ((name-space (send ((caar lst) *key*) get-name-space))
  144.                (fn (if (member msg '(get-settable 
  145.                                      get-inittable get-gettable get-mixins))
  146.                        (lambda (x)(member x name-space))
  147.                        (lambda (x)(member (car x) name-space)))))     
  148.               (append (cdar lst)
  149.                       (filter (shadow (cdr lst) msg) fn))))))))
  150.     (lambda (class msg)
  151.       (shadow
  152.        (map-inheritance class msg) msg))))
  153.  
  154. (define lookup-class
  155.   (let ((*key* *key*))
  156.     (rec lookup-class
  157.             (lambda (name cl)
  158.               (cond
  159.                ((null? cl) (cerror "illegal class name" name))
  160.                ((eq? (send ((car cl) *key*) name) name) (car cl))
  161.                (else (lookup-class name (cdr cl))))))))
  162.  
  163. ;The efficiency here could be improved by caching functions
  164.  
  165. (define process-option
  166.   (let ((*key* *key*))
  167.     (lambda (class option)
  168.       (cond
  169.        ((atom? option)
  170.         (case option
  171.           ((settable-variables)
  172.            (for-each (dispatch (class *key*) 'add-settable) 
  173.                      (mapcar car (append
  174.                                   (send (class *key*) get-instvars)
  175.                                   (send (class *key*) get-classvars)))))
  176.           ((gettable-variables)
  177.            (for-each (dispatch (class *key*) 'add-gettable)
  178.                      (mapcar car (append
  179.                                   (send (class *key*) get-instvars)
  180.                                   (send (class *key*) get-classvars)))))
  181.           ((inittable-variables)
  182.            (for-each (dispatch (class *key*) 'add-inittable)
  183.                      (mapcar car (append
  184.                                   (send (class *key*) get-instvars)
  185.                                   (send (class *key*) get-classvars)) )))))
  186.        (else
  187.         (case (car option)
  188.           ((settable-variables)
  189.            (for-each (dispatch (class *key*) 'add-settable)
  190.                      (cdr option)))
  191.           ((gettable-variables)
  192.            (for-each (dispatch (class *key*) 'add-gettable)
  193.                      (cdr option)))
  194.           ((inittable-variables)
  195.            (for-each (dispatch (class *key*) 'add-inittable)
  196.                      (cdr option)))))))))
  197.  
  198. (define process-tail
  199.   (let ((class-list class-list)
  200.         (*key* *key*)
  201.         (lookup-class lookup-class)
  202.         (process-option process-option))
  203.     (rec process-tail
  204.          (lambda (class tail)
  205.            (cond 
  206.             ((null? tail) class)
  207.             (else
  208.              (case (caar tail)
  209.                ((classvars)
  210.                 (for-each (dispatch (class *key*) 'add-classvar)
  211.                           (cdar tail)))
  212.                ((instvars)
  213.                 (for-each (dispatch (class *key*) 'add-instvar)
  214.                           (cdar tail)))
  215.                ((methods)
  216.                 (for-each (dispatch (class *key*) 'add-method)
  217.                           (cdar tail)))
  218.                ((mixins)
  219.                 (let ((fn (dispatch (class *key*) 'add-mixin)))
  220.                   (for-each (lambda (x) (fn (lookup-class x (class-list))))
  221.                             (cdar tail))))
  222.                ((options)
  223.                 (for-each (lambda (x) (process-option class x))
  224.                           (cdar tail))))
  225.              (process-tail class (cdr tail))))))))
  226.  
  227. ;Helper functions
  228.  
  229. (define instance-vars
  230.   (let ((inheritance inheritance))
  231.     (lambda (x)
  232.       (inheritance x 'get-instvars))))
  233.  
  234. (define class-vars
  235.   (let ((inheritance inheritance))
  236.     (lambda (x)
  237.       (inheritance x 'get-classvars))))
  238.  
  239. (define eqcar
  240.   (lambda (x y) (eq? (car x) (car y))))
  241.  
  242. (define attach-prefix
  243.   (lambda (prefix symbol)
  244.     (string->symbol (string-append prefix (symbol->string symbol)))))
  245.  
  246. (define remdup)
  247. (define union)
  248.  
  249. (let ()
  250.   (define (member? x y test)
  251.     (cond
  252.      ((null? y) '())
  253.      ((test x (car y)) #t)
  254.      (else (member? x (cdr y) test))))
  255.   (define (remdup1 y x equality)
  256.       (cond
  257.        ((null? x) (reverse y))
  258.        ((member? (car x) y equality) (remdup1 y (cdr x) equality))
  259.        (else (remdup1 (cons (car x) y) (cdr x) equality))))
  260.   (set! remdup
  261.         (lambda (x equality) (remdup1 '() x equality)))
  262.   (set! union
  263.         (rec union
  264.              (lambda (x y equality)
  265.                (cond
  266.                 ((null? x) y)
  267.                 ((member? (car x) y equality) (union (cdr x) y equality))
  268.                 (else (cons (car x) (union (cdr x) y equality))))))))
  269.  
  270. (define add-member
  271.   (lambda (x y . fn)
  272.     ((if (null? fn)
  273.          (rec loop (lambda (z)
  274.                      (cond
  275.                       ((null? z) (list x))
  276.                       ((eq? x (car z)) (cons x (cdr z)))
  277.                       (else (cons (car z) (loop (cdr z)))))))
  278.          (let* ((fn (car fn)) (name (fn x)))
  279.            (rec loop (lambda (z)
  280.                        (cond
  281.                         ((null? z) (list x))
  282.                         ((eq? name (fn (car z)))
  283.                          (cons x (cdr z)))
  284.                         (else (cons (car z) (loop (cdr z))))))))) y)))
  285.  
  286. (define delete
  287.   (rec delete
  288.        (lambda (x y test)
  289.          (cond
  290.           ((null? y) '())
  291.           ((test x (car y)) (cdr y))
  292.           (else (cons (car y) (delete x (cdr y) test)))))))
  293.  
  294. (define set-value
  295.   (lambda (env loc value)
  296.     (vector-set! (car env) loc value)
  297.     value))
  298.  
  299. (define get-value
  300.   (lambda (env loc)
  301.     (vector-ref (car env) loc)))
  302.  
  303. (define locate
  304.   (letrec ((locate1
  305.             (lambda (x y n)
  306.               (cond
  307.                ((null? y)
  308.                 (cerror
  309.                  "tried to locate a non-existant variable in environment"))
  310.                ((eq? x (caar y)) n)
  311.                (else (locate1 x (cdr y) (1+ n)))))))
  312.     (lambda (x y)
  313.       (locate1 x y 0))))
  314.  
  315. (define class-description
  316.   (let ((*key* *key*)
  317.         (inheritance inheritance)
  318.         (writeln (lambda l (for-each display l) (newline))))
  319.     (lambda (class)
  320.       (writeln " ")
  321.       (writeln "    CLASS DESCRIPTION    ")
  322.       (writeln "    ==================    ")
  323.       (writeln " ")
  324.       (writeln " NAME            : " (send (class *key*) name))
  325.       (writeln " CLASS VARS      : "
  326.                (mapcar car (inheritance class 'get-classvars )))
  327.       (writeln " INSTANCE VARS   : "
  328.                (mapcar car (inheritance class 'get-instvars )))
  329.       (writeln " METHODS         : "
  330.                (mapcar car (inheritance class 'get-methods)))
  331.       (writeln " MIXINS          : "
  332.                (mapcar (lambda (x)
  333.                          (send (x *key*) name))
  334.                        (inheritance class 'get-mixins)))
  335.       (writeln " CLASS COMPILED  : "
  336.                (not (null? (send (class *key*) compiled?))))
  337.       
  338.       (writeln " CLASS INHERITED : "
  339.                (mapcar (lambda (x) (send (x *key*) name))
  340.                        (send (class *key*) get-subclasses)))
  341.       (string->symbol ""))))
  342.  
  343. (define instance-description
  344.   (let ((*key* *key*)
  345.         (inheritance inheritance)
  346.         (writeln (lambda l (for-each display l) (newline))))
  347.     (lambda (inst)
  348.       (letrec ((class (send inst get-class))
  349.                (printvars
  350.                 (lambda (f1 f2) ;f1 is a list of instvars and f2 an environment
  351.                   (let ((n 0))
  352.                     (while f1
  353.                            (writeln "   " (car f1) " : " (vector-ref f2 n))
  354.                            (set! n (1+ n))
  355.                            (set! f1 (cdr f1)))))))
  356.         
  357.         (writeln " ")
  358.         (writeln "  INSTANCE DESCRIPTION      ")
  359.         (writeln "  ====================      ")
  360.         (writeln " ")
  361.         (writeln " Instance of Class " (send (class *key*) name))
  362.         (writeln " ")
  363.         (writeln " Class Variables : ")
  364.         (printvars (mapcar car (inheritance class 'get-classvars ))
  365.                    (car(send (class *key*) get-class-environment)))
  366.         (writeln " ")
  367.         (writeln "Instance Variables :")
  368.         (printvars (mapcar car (inheritance class 'get-instvars))
  369.                    (cadr (->pair (car (->pair inst)))))
  370.         (string->symbol "")
  371.         ))))
  372.  
  373.  
  374. ;;; this is the beginning of the main lexical environment of SCOOPS
  375.  
  376. (let ((key *key*)
  377.       (inheritance inheritance)
  378.       (lookup-class lookup-class)
  379.       (process-tail process-tail)
  380.       (process-option process-option)
  381.       (instance-vars instance-vars)
  382.       (class-vars class-vars)
  383.       (eqcar eqcar)
  384.       (attach-prefix attach-prefix)
  385.       (remdup remdup)
  386.       (union union)
  387.       (add-member add-member)
  388.       (delete delete)
  389.       (set-value set-value)
  390.       (get-value get-value)
  391.       (locate locate)
  392.       (class-description class-description)
  393.       (instance-description instance-description)
  394.       (class-list class-list)
  395.       (class-list-set! class-list-set!))
  396.    
  397.    (define *key* key) ; the key for classes in this environment
  398.    
  399.    ;this monster is the framework for creating classes.  Obviously 
  400.    ;improvement in speed could be made by using records instead of
  401.    ;lexical environments. However, we should see what the dispatching
  402.    ;overhead is before making such a change.  I have used a key in the
  403.    ;following definition so that foreign code cannot send messages directly
  404.    ;to classes.
  405.    
  406.    (define make-class 
  407.      (lambda (name)
  408.        (letrec 
  409.          ((classvars '())
  410.           (instvars  '())
  411.           (mixins '())
  412.           (gettable '())
  413.           (settable '())
  414.           (inittable '()) 
  415.           (methods '()) 
  416.           (make-fn '())
  417.           (subclasses '())
  418.           (all-classvars '())
  419.           (all-settable '())
  420.           (all-gettable '())
  421.           (self 
  422.            (lambda x
  423.              (if (and x (eq? (car x) *key*))
  424.                  (->symbol
  425.                   (list
  426.                    (lambda (msg)
  427.                      (case msg
  428.                        
  429.                        ;we put make-instance first to minimize dispatching time
  430.                        ((make-instance)
  431.                         (if (null? make-fn) 
  432.                             (set! make-fn
  433.                                   (eval (compile-make-fn self)
  434.                                         class-environment)))
  435.                         (lambda x (apply make-fn x)))
  436.                        ((getcv)
  437.                         (lambda (x)
  438.                           (if (member x all-gettable)
  439.                               (get-value class-environment
  440.                                          (locate x all-classvars))
  441.                               (cerror "variable not gettable" x))))
  442.                        ((setcv)
  443.                         (lambda (x y)
  444.                           (if (member x all-settable)
  445.                               (set-value class-environment
  446.                                          (locate x all-classvars)
  447.                                          y)
  448.                               (cerror "variable not settable" x))))
  449.                        ((name) (lambda () name))
  450.                        ((set-name) (lambda (x)(set! name x)))
  451.                        ((get-subclasses) (lambda () subclasses))
  452.                        ((add-subclass)
  453.                         (lambda (x)
  454.                           (set! subclasses 
  455.                                 (add-member x
  456.                                             subclasses
  457.                                             (lambda (x)
  458.                                               (send (x *key*) name))))))
  459.                        ((remove-subclass)
  460.                         (lambda (x)
  461.                           (set! subclasses (remove x subclasses))))
  462.                        
  463.                        ((get-methods) (lambda () methods))
  464.                        ((delete-method)
  465.                         (lambda (x)
  466.                           (set! methods (delete x methods eqcar))
  467.                           (send self nil-make-fn)))
  468.                        ((nil-make-fn)
  469.                         (lambda ()
  470.                           (set! make-fn '())
  471.                           (mapcar (lambda (x)
  472.                                     (send (x *key*) nil-make-fn))
  473.                                   subclasses)))
  474.                        ((add-method)
  475.                         (lambda (x)
  476.                           (send (self *key*)  nil-make-fn)
  477.                           (set! methods (add-member x methods car))))
  478.                        ((add-classvar)
  479.                         (lambda (x)
  480.                           (set! classvars
  481.                                 (add-member (if (atom? x)
  482.                                                 (cons x '())
  483.                                                 (cons (car x) (cadr x)))
  484.                                             classvars 
  485.                                             car))))
  486.                        
  487.                        ((set-all-classvars)
  488.                         (lambda (x) (set! all-classvars x)))
  489.                        ((get-classvars) (lambda () classvars))
  490.                        ((get-all-classvars) (lambda () all-classvars))
  491.                        ((add-instvar)
  492.                         (lambda (x)
  493.                           (set! instvars 
  494.                                 (add-member (if (atom? x)
  495.                                                 (cons x '())
  496.                                                 (cons (car x)(cadr x)))
  497.                                             instvars
  498.                                             car))))
  499.                        ((get-instvars) (lambda () instvars))
  500.                        ((add-mixin)
  501.                         (lambda (x)
  502.                           (send (x *key*) add-subclass self)
  503.                           (set! mixins (add-member x mixins ))))
  504.                        ((get-all-instvars)
  505.                         (inheritance self 'get-instvars eqcar))
  506.                        ((get-mixins) (lambda () mixins))
  507.                        ((get-inittable) (lambda () inittable))
  508.                        
  509.                        ((add-inittable)
  510.                         (lambda (x)
  511.                           (set! make-fn '())
  512.                           (set! inittable 
  513.                                 (add-member x inittable))))
  514.                        ((get-settable) (lambda () settable))
  515.                        ((add-settable)
  516.                         (lambda (x)
  517.                           (set! make-fn '())
  518.                           (set! settable (add-member x settable ))))
  519.                        ((set-all-settable)
  520.                         (lambda (x)(set! all-settable x)))
  521.                        ((get-gettable) (lambda () gettable))
  522.                        ((add-gettable)
  523.                         (lambda (x)
  524.                           (set! make-fn '())
  525.                           (set! gettable (add-member x gettable))))
  526.                        ((set-all-gettable)
  527.                         (lambda (x) (set! all-gettable x)))
  528.                        ((compiled?) (lambda () make-fn))
  529.                        ((compile)
  530.                         (lambda ()
  531.                           (set! make-fn
  532.                                 (eval (compile-make-fn self)
  533.                                       class-environment))
  534.                           ))
  535.                        ((get-name-space)
  536.                         (lambda ()
  537.                           (append mixins
  538.                                   (mapcar car
  539.                                           (append classvars
  540.                                                   instvars
  541.                                                   methods)))))
  542.                        ((set-make-fn)
  543.                         (lambda (fn)
  544.                           (set! class-environment
  545.                                 (cdr (->pair fn)))
  546.                           (set! make-fn fn)))
  547.                        ((get-make-fn)
  548.                         (lambda () (compile-make-fn self)))
  549.                        ((get-class-environment)
  550.                         (lambda () class-environment))
  551.                        ))
  552.                    (cons 'pname
  553.                          (string-append "class:"
  554.                                         (symbol->string name)))))
  555.                  (cerror "private object, key required" self)
  556.                  ))))
  557.          self)))
  558.    
  559.    (define define-class-fn 
  560.      (lambda x
  561.        (let ((class (process-tail (make-class (car x)) (cdr x))))
  562.          (class-list-set!
  563.           (add-member class
  564.                       (class-list) 
  565.                       (lambda (x) (send (x *key*) name))))
  566.          
  567.          ;the following list need to be cached to support getcv and setcv 
  568.          (send (class *key*)
  569.                set-all-classvars
  570.                (inheritance class 'get-classvars))
  571.          (send (class *key*)
  572.                set-all-gettable
  573.                (inheritance class 'get-gettable))
  574.          (send (class *key*)
  575.                set-all-settable
  576.                (inheritance class 'get-settable))
  577.          (send (class *key*)  nil-make-fn)
  578.          class)))
  579.    
  580.    (define compile-make-fn
  581.      (lambda (x)
  582.        (let* ((params (gensym "init-parms"))
  583.               (instvars (instance-vars x))
  584.               (totalvars (append instvars (class-vars x))))
  585.          `(lambda
  586.            ,params
  587.             (letrec
  588.               ,(append
  589.                 (format-vars instvars)
  590.                 (list
  591.                  (list 'self 
  592.                        `(lambda
  593.                          msg
  594.                          (case (car msg)
  595.                            ,@(format-case 
  596.                               (append
  597.                                `((get-class (lambda (),x)))
  598.                                (get-methods (inheritance x 'get-gettable)
  599.                                             totalvars)
  600.                                (set-methods (inheritance x 'get-settable)
  601.                                             totalvars)
  602.                                (inheritance x 'get-methods)
  603.                                )))))))
  604.               ,(compile-init-code x params)
  605.               (->symbol
  606.                (list self 
  607.                      ',(cons 'pname 
  608.                              (string-append "instance:"
  609.                                             (symbol->string 
  610.                                              (send (x *key*) name)))))))))))
  611.    
  612.    
  613.    
  614.    (define compile-init-code
  615.      (lambda (x init-params)
  616.        `(while ,init-params
  617.                 (cond
  618.                  ,@(condition-actions (inheritance x 'get-inittable)
  619.                                       init-params)
  620.                    (else (error "variable not inittable"
  621.                                 (car ,init-params)))) 
  622.                 (set! ,init-params (cddr ,init-params)))))
  623.    
  624.    (define condition-actions
  625.      (lambda (vars init-params)
  626.        (mapcar (lambda (x)
  627.                  `((eq? (car ,init-params) ',x)
  628.                    (set! ,x (cadr ,init-params))))
  629.                vars)))
  630.    
  631.    (define compile-class-environment
  632.      (lambda (x)
  633.        (letrec ((var (send x get-classvars))
  634.                 (env (make-vector (1+ (length var)) '())))
  635.          (vector-set! env (length var) (mapcar (lambda (x) (car x)) var))
  636.          (list env))))
  637.    
  638.    (define format-case
  639.      (lambda (x)
  640.        (append (mapcar (lambda (y) (cons (list (car y)) (cdr y)))
  641.                        x)
  642.                '((else (if (cdr msg) ((cadr msg)) '#f))))))
  643.    
  644.    (define format-vars
  645.      (lambda (all-vars)
  646.        (mapcar (lambda (y) (list (car y) (unwindinitval (cdr y))))
  647.                all-vars)))
  648.    
  649.    (define unwindinitval
  650.      (lambda (y)
  651.        (cond
  652.         ((and (pair? y) (eq? (car y) 'active))
  653.          (unwindinitval (cadr y)))
  654.         (else y))))
  655.    
  656.    
  657.    (define get-methods
  658.      (lambda (lst all-vars)
  659.        (mapcar (lambda (x)  ;x = var
  660.                  (let ((y (assq x all-vars)))
  661.                    ; y = (x . form) | (x . (active form getfn setfn))
  662.                    (if (null? y) 
  663.                        (cerror "cannot make get-var function for" x)
  664.                        (list (attach-prefix "get-" x)
  665.                              `(lambda () ,(unwindgetfn x (cdr y)))))))lst)))
  666.    
  667.    (define unwindgetfn
  668.      (lambda (var vardefn)
  669.        (cond
  670.         ((and (pair? vardefn) (eq? (car vardefn) 'active))
  671.          (list (caddr vardefn) (unwindgetfn var (cadr vardefn))))
  672.         (else var))))
  673.    
  674.    
  675.    
  676.    (define set-methods
  677.      (let ((*a1* (gensym)))
  678.        (lambda (lst all-vars)
  679.          (mapcar (lambda (x) 
  680.                    (let ((y (assq x all-vars)))
  681.                      (if (null? y)
  682.                          (cerror "cannot make set-var function for " x)
  683.                          (list (attach-prefix "set-" x) 
  684.                                `(lambda (,*a1*)
  685.                                         (set! ,x
  686.                                                ,(unwindsetfn *a1*
  687.                                                              (cdr y))))))))
  688.                  lst))))
  689.    
  690.    
  691.    
  692.    (define unwindsetfn
  693.      (lambda (parm vardefn)
  694.        (cond
  695.         ((and (pair? vardefn) (eq? (car vardefn) 'active))
  696.          (list (cadddr vardefn) (unwindsetfn parm (cadr vardefn))))
  697.         (else parm))))
  698.    
  699.    ;;;exports
  700.    
  701.    (set! describe
  702.          (lambda (class-inst)
  703.            (if (member  class-inst (class-list))
  704.                (class-description class-inst)
  705.                (instance-description class-inst))))
  706.    
  707.    
  708.    (set! name->class
  709.          (lambda (x)(lookup-class x (class-list))))
  710.    
  711.    
  712.    ;the following may as well use the cached all-classvars
  713.    (set! all-classvars
  714.          (lambda (obj) (mapcar car (send (obj *key*) get-all-classvars))))
  715.    
  716.    (set! all-instvars
  717.          (lambda (obj) (mapcar car (inheritance obj 'get-instvars))))
  718.    
  719.    
  720.    (set! all-methods
  721.          (lambda (obj) (inheritance obj 'get-methods )))
  722.    
  723.    (set! class-compiled?
  724.          (lambda (obj) (if (send (obj *key*) compiled?) #t #f)))
  725.    
  726.    (set! class-of-object
  727.          (lambda (obj) (send ((send obj get-class) *key*) name)))
  728.    
  729.    (set! classvars
  730.          (lambda (obj) (mapcar car (send (obj *key*) get-classvars))))
  731.    
  732.    (set! compile-class
  733.          (lambda (obj) (send (obj *key*) compile)))
  734.    
  735.    (macro define-class
  736.           (lambda (x)
  737.             (let* ((new-class (apply define-class-fn (cdr x)))
  738.                    ;(foo (display (list 'env (send (location *key*)
  739.                    ;                               get-class-environment))))
  740.                    (class-vars (format-vars (send (new-class *key*)
  741.                                                   get-all-classvars)))
  742.                    (code (compile-make-fn new-class))
  743.                    (name (send (new-class *key*) name)))
  744.               `(begin 
  745.                 (set! ,name ,new-class)
  746.                 (send (,new-class ',*key*) set-make-fn
  747.                                            (let ,class-vars
  748.                                              ,code))))))
  749.    
  750.    
  751.    (macro define-method
  752.           (lambda (x) ; x =  (define-method (class method) (...args...) body)
  753.             `(send (,(caadr x) ',*key*)
  754.                    add-method
  755.                    ',(list (cadadr x) `(lambda ,(caddr x) ,(cadddr x))))))
  756.    (macro delete-method
  757.           (lambda (x) ; x = (delete-method (class method))
  758.             `(send (,(name->class (caadr x)) ',*key*)
  759.                    delete-method
  760.                    (cadadr x))))
  761.    
  762.    
  763.    (macro getcv
  764.           (lambda (x) ; x = (getcv obj var)
  765.             `(send (,(cadr x) ',*key*) getcv ',(caddr x))))
  766.    
  767.    (macro setcv
  768.           (lambda (x) ; x = (setcv obj var newval)
  769.             `(send (,(cadr x) ',*key*) setcv ',(caddr x) ,(cadddr x))))
  770.    
  771.    (set! instvars
  772.          (lambda (obj)(send (obj *key*) get-instvars)))
  773.    
  774.    (macro make-instance
  775.           (lambda (x) ; x = (make-instance class var val var val ... )
  776.             `(send (,(cadr x) ',*key*) make-instance ,@(cddr x))))
  777.    
  778.    (set! methods
  779.          (lambda (obj) (send (obj *key*) get-methods)))
  780.    
  781.    (set! mixins
  782.          (lambda (obj)(mapcar (lambda (x)(send (x *key*) name))
  783.                               (send (obj *key*) get-mixins))))
  784.    
  785.    (macro rename-class (lambda (x) ; x = (rename-class (class newname))
  786.                          `(send (,(caadr x) ',*key*) set-name ',(cadadr x))))
  787.    
  788.    
  789.    )
  790.  
  791. (define *key*)
  792. (define inheritance)
  793. (define lookup-class)
  794. (define process-tail)
  795. (define process-option)
  796. (define instance-vars)
  797. (define class-vars)
  798. (define eqcar)
  799. (define attach-prefix)
  800. (define remdup)
  801. (define union)
  802. (define add-member)
  803. (define delete)
  804. (define set-value)
  805. (define get-value)
  806. (define locate)
  807. (define class-description)
  808. (define instance-description)
  809. (define class-list)
  810. (define class-list-set!)
  811.  
  812. (begin (set! include-source-code? #t)
  813.        (set! include-lambda-list? #t)
  814.        (set! include-procedure-name? #t))